
(load "../common/common.ss")

(define indent "   ")
(define indent2 "      ")
(define indent3 "         ")
(define indent4 "            ")
(define indent-cmd "$          ")
(define eol "\n")

(define *user-type* 'development)

(define (display-attr indent attr-name attr-value)
    (display (string-append indent "<" attr-name ">" (make-string attr-value)
                                   "</" attr-name ">" eol))
)

(define (display-cmd title cmd squid)
    (if (not (null? title))
        (display (string-append title eol))
        #f)
    (display (string-append indent-cmd cmd))
    (if (not (null? squid))
        (display (string-append " --squser=" (make-string squid)))
        #f)
    (display eol)
)

(define (id-list lst)
    (string-join (map (compose make-string get-id) lst) ","))

(define (make-msa id slots usage)
    (define (show)
        (display (string-append indent2 "<msa>" eol))
        (display-attr indent3 "id" id)
        (display-attr indent3 "slots" (make-string slots))
        (display-attr indent3 "usage" (make-string usage))
        (display (string-append indent2 "</msa>" eol))
        'Done
    )
    (define (build)
        (display-cmd nil "# managevdisks --reset --msa=" id)
        'Done
    )
    (define (delete)
        (display-cmd nil "# managevdisks --delete --all --msa=" id)
        'Done
    )
    (define (dispatch op)
        (cond ( (eq? op 'id) id )
              ( (eq? op 'slots) slots )
              ( (eq? op 'usage) usage )
              ( (eq? op 'show) (show) )
              ( (eq? op 'build) (build) )
              ( else (error "Invalid op for msa" op) )))
    dispatch)

(define (make-node id cores processors usage)
     (define (show)
        (display (string-append indent2 "<node>" eol))
        (display-attr indent3 "id" id)
        (display-attr indent3 "cores" (make-string cores))
        (display-attr indent3 "processors" (make-string processors))
        (display-attr indent3 "usage" (make-string usage))
        (display (string-append indent2 "</node>" eol))
        'Done
    )
    (define (build) 'Done)
    (define (dispatch op)
        (cond ( (eq? op 'id) id )
              ( (eq? op 'cores) cores )
              ( (eq? op 'processors) processors )
              ( (eq? op 'usage) usage )
              ( (eq? op 'show) (show) )
              ( (eq? op 'build) (build) )
              ( else (error "Invalid op for node" op) )))
    dispatch)

(define (make-cab id lstmsa lstnode)
    (define (show)
        (display (string-append indent "<cabinet>" eol))
        (display-attr indent2 "id" (make-string id))
        (for-each (lambda (msa) (show-obj msa)) lstmsa)
        (for-each (lambda (node) (show-obj node)) lstnode)
        (display (string-append indent "</cabinet>" eol))
        'Done
    )
    (define (build)
        (for-each (lambda (msa) (build-obj msa)) lstmsa)
        (for-each (lambda (node) (build-obj node)) lstnode)
        'Done
    )
    (define (dispatch op)
        (cond ( (eq? op 'id) id )
              ( (eq? op 'msas) lstmsa )
              ( (eq? op 'nodes) lstnode )
              ( (eq? op 'show) (show) )
              ( (eq? op 'build) (build) )
              ( else (error "Invalid op for cabinet" op) )))
    dispatch)

(define (make-user id group password permission sqconfig
                   sql-nodes conn-nodes tlog-nodes system-nodes)
;    (if (null? tlog-nodes) (set! tlog-nodes (car sql-nodes)) )
    (define (show)
        (display (string-append indent2 "<users>" eol))
        (display-attr indent3 "id" id)
        (display-attr indent3 "group" group)
        (display-attr indent3 "password" password)
        (display-attr indent3 "permission" permission)
        (display-attr indent3 "sqconfig" sqconfig)
        (display-attr indent3 "sql_node" (id-list sql-nodes))
        (display-attr indent3 "conn_node" (id-list conn-nodes))
        (display-attr indent3 "node_for_tlog" (id-list tlog-nodes))
        (display-attr indent3 "node_for_system" (id-list system-nodes))
        (display (string-append indent2 "</users>" eol))
        'Done
    )
    (define (build)
        (display (string-append indent2 "Building user :-- "
                                (make-string id) eol))
        (display-cmd nil "managesquser --add" id)
        (display-cmd nil "sqconfig_gen" id)
        (if (eq? *user-type* 'development)
            (display-cmd nil "stafinit" id)
            (display-cmd nil "manualinit" id))
        'Done
    )
    (define (delete)
        (display (string-append indent2 "Destroying user :-- "
                                (make-string id) eol))
        (display-cmd nil "managesquser --del" id)
        'Done
    )
    (define  (dispatch op)
        (cond ( (eq? op 'id) id )
              ( (eq? op 'group) group )
              ( (eq? op 'password) password )
              ( (eq? op 'sqconfig) sqconfig )
              ( (eq? op 'sql-nodes) sql-nodes )
              ( (eq? op 'conn-nodes) conn-nodes )
              ( (eq? op 'tlog-nodes)
                  (if (not (null? tlog-nodes)) tlog-nodes
                      (car sql-nodes)) )
              ( (eq? op 'system-nodes)
                  (if (not (null? system-nodes)) system-nodes
                      (cadr sql-nodes)) )
              ( (eq? op 'show) (show) )
              ( (eq? op 'build) (build) )
              ( (eq? op 'delete) (delete) )
              ( else (error "Invalid op" op) )))
    dispatch)

(define (make-instance id sqconfig storage-type user-type
                      bdr-name bdr-port disable-firewall float-ip-flag
                      sql-nodes conn-nodes spare-nodes no-of-ase no-of-tse
                      tlog-nodes system-nodes
                      msa-list
                      user-list
                      contact comments)
    (set! *user-type* user-type)
    (define (first-uid)
        (if (null? user-list)
            (error "Empty user list --instance=" id)
            (get-id (car user-list))))
    (define (show)
        (display (string-append indent "<instance_cfgs>" eol))
        (display-attr indent2 "id" id)
        (display-attr indent2 "sqconfig" sqconfig)
        (display-attr indent2 "storage_type" storage-type)
        (display-attr indent2 "user_type" user-type)
        (display-attr indent2 "bdr_name" bdr-name)
        (display-attr indent2 "bdr_port" (make-string bdr-port))
        (display-attr indent2 "disable_firewall" disable-firewall)
        (display-attr indent2 "float_ip_flag" float-ip-flag)
        (display-attr indent2 "sql_node" (id-list sql-nodes))
        (display-attr indent2 "conn_node" (id-list conn-nodes))
        (display-attr indent2 "spare_node" (id-list spare-nodes))
        (display-attr indent2 "number_of_ase" (make-string no-of-ase))
        (display-attr indent2 "number_of_tse" (make-string no-of-tse))
        (display-attr indent2 "node_for_tlog" (id-list tlog-nodes))
        (display-attr indent2 "node_for_system" (id-list system-nodes))
        (display-attr indent2 "msa_list" (id-list msa-list))

        (for-each (lambda (user) (show-obj user)) user-list)

        (display (string-append indent "</instance_cfgs>" eol))
        'Done
    )
    (define (build)
        (display (string-append indent "Building instance :-- "
                                (make-string id) eol))
        (display-cmd (string-append indent2 "Checking exar card")
                     "exarconf" (first-uid) )
        (display-cmd (string-append indent2 "Initializing msa")
                     "instance_msaconfig" (first-uid))
        (display-cmd (string-append indent2 "Dumping msa info")
                     "dumpmsainfo" (first-uid))
        (display-cmd (string-append indent2 "Formating disks")
                     "lunconfig" (first-uid))

        (for-each (lambda (user) (build-obj user)) user-list)

        (display-cmd (string-append indent2 "Mapping storage")
                     "mapsqstorage" (first-uid))
        (display-cmd (string-append indent2 "Mounting database dirs")
                     "dbmounts" (first-uid))
        (display-cmd (string-append indent2 "Setting db dir permissions")
                     "set_dbperms" (first-uid))
        'Done
    )

    (define (find-user uid)
        (find-if (lambda (user) (eq? uid (get-id user))) user-list)
    )

    (define (add-user user)
        (display (string-append indent2 "Adding user:"
                                (make-string (get-id user)) eol))
        (if (find-user (get-id user))
            (error "Existing user --ADD-USER" (get-id user))
            (begin
                (build-obj user)
                (set! user-list (append user-list (list user)))))
        user-list)

    (define (del-user uid)
        (define (remove-user! uid)
            (set! user-list (remove-if (lambda (user) (eq? uid (get-id user)))
                                   user-list))
            user-list)
        (display (string-append indent "Deleting user:"
                                (make-string uid) eol))
        (let ( (user (find-user uid)) )
            (if (not user)
                (error "Invalid user --DEL-USER" uid)
                (begin
                    (del-obj user)
                    (remove-user! uid))))
    )
    (define (delete)
        (display (string-append indent "Destroying instance :-- "
                                (make-string id) eol))
        (display-cmd (string-append indent2 "Destroying msa")
                     "instance_msaconfig --undo" (first-uid))
        'Done
    )
    (define (dispatch op)
        (cond ( (eq? op 'id) id )
              ( (eq? op 'sqconfig) sqconfig )
              ( (eq? op 'storage-type) storage-type )
              ( (eq? op 'user-type) user-type )
              ( (eq? op 'bdr-name) bdr-name )
              ( (eq? op 'bdr-port) bdr-port )
              ( (eq? op 'disable-firewall) disable-firewall )
              ( (eq? op 'float-ip-flag) float-ip-flag )
              ( (eq? op 'sql-nodes) sql-nodes )
              ( (eq? op 'conn-nodes) conn-nodes )
              ( (eq? op 'spare-nodes) spare-nodes )
              ( (eq? op 'no-of-ase) no-of-ase )
              ( (eq? op 'no-of-tse) no-of-tse )
              ( (eq? op 'tlog-nodes) tlog-nodes )
              ( (eq? op 'system-nodes) system-nodes )
              ( (eq? op 'msas) msa-list )
              ( (eq? op 'users) user-list )
              ( (eq? op 'show) (show) )
              ( (eq? op 'build) (build) )
              ( (eq? op 'delete) (delete) )
              ( (eq? op 'add-user) add-user )
              ( (eq? op 'del-user) del-user )
              ( else (error "Invalid op for instance" op) )))
    dispatch)

(define (make-cluster id ip cluster-type msa-typefile node-type profile
                      requestor comments lstcab lstinst)
    (define (show)
        (display "<?xml version=\"1.0\"?>\n")
        (display (string-append "<cluster_conf>" eol))
        (display-attr indent "cluster_name" id)
        (display-attr indent "cluster_ip" ip)
        (display-attr indent "cluster_type" cluster-type)
        (display-attr indent "msa_typefile" msa-typefile)
        (display-attr indent "node_type" node-type)
        (display-attr indent "profile" profile)
        (display-attr indent "requestor" requestor)
        (display-attr indent "comments" comments)

        (for-each (lambda (cab) (show-obj cab)) lstcab)
        (for-each (lambda (inst) (show-obj inst)) lstinst)

        (display (string-append "</cluster_conf>" eol))
        'Done
    )
    (define (build)
        (display (string-append "Building cluster :-- " (make-string id) eol))
        (for-each (lambda (cab) (build-obj cab)) lstcab)
        (for-each (lambda (inst) (build-obj inst)) lstinst)

        (display-cmd (string-append indent "Recording version")
                     "record_version" nil)
        (display-cmd (string-append indent "Sunc heanodes")
                     "sync_headnodes" nil)
        'Done
    )

    (define (add-user user)
        (if (not (eq? cluster-type 'shared))
            (error "Invalid cluster type --ADD-USER" cluster-type)
            (begin
                (display-cmd (string-append indent "Updating config")
                    "instconfig --add" (get-id user))
                (((car lstinst) 'add-user) user)
                (display-cmd (string-append indent "Sunc heanodes")
                     "sync_headnodes" nil)))
        lstinst)

    (define (del-user uid)
        (if (not (eq? cluster-type 'shared))
            (error "Invalid cluster type --DEL-USER" cluster-type)
            (begin
                (((car lstinst) 'del-user) uid)
                (display-cmd (string-append indent "Updating config")
                    "instconfig --del" uid)
                (display-cmd (string-append indent "Sunc heanodes")
                     "sync_headnodes" nil)))
        lstinst)

    (define (add-instance instance)
        (if (not (eq? cluster-type 'sliced))
            (error "Invalid cluster type --ADD-INSTANCE" cluster-type)
            (begin
                (display (string-append indent "Adding instance:"
                                (make-string (get-id instance)) eol))
                (build-obj instance)
                (set! lstinst (append lstinst (list instance)))
                (display-cmd (string-append indent "Sunc heanodes")
                     "sync_headnodes" nil)))
        lstinst)

    (define (dispatch op)
        (cond ( (eq? op 'id) id )
              ( (eq? op 'ip) ip )
              ( (eq? op 'cluster-type) cluster-type )
              ( (eq? op 'msa-typefile) msa-typefile )
              ( (eq? op 'node-type) node-type )
              ( (eq? op 'profile) profile )
              ( (eq? op 'cabs) lstcab )
              ( (eq? op 'instances) lstinst )
              ( (eq? op 'show) (show) )
              ( (eq? op 'build) (build) )
              ( (eq? op 'add-user) add-user )
              ( (eq? op 'add-instance) add-instance )
              ( (eq? op 'del-user) del-user )
              ( (eq? op 'del-instance) del-instance )
              ( else (error "Invalid op for cluster" op) )))
    dispatch)

(define (get-id obj) (obj 'id))

(define (show-obj obj) (obj 'show))
(define (build-obj obj) (obj 'build))
(define (del-obj obj) (obj 'delete))
